perm filename EXPLAI[DEN,LMM] blob
sn#070827 filedate 1973-11-09 generic text, type T, neo UTF8
(FILECREATED " 9-NOV-73 0:59:44" S-EXPLAIN
changes to: EXPLAINRINGSKEL
previous date: " 5-NOV-73 0:52:59")
(LISPXPRINT (QUOTE EXPLAINVARS)
T)
(RPAQQ EXPLAINVARS
((* Everything needed to do an "EXPLAIN" command)
(FNS EXPLAIN PRINCL BONDING PRINU PRINMB PRINNUMLIS
PRINNUMLISTS EXPLAINVALENTNODE PRIN1L EXPLAINUPDATEFLG
WHERE STRUCFORMLEVEL)
(FNS EXPLAINATIONMOLECULES EXPLAINGENMOL EXPLAINRINGS
EXPLAINSTRUCWAT EXPLAINRINGSKEL EXPLAINATTACFVS
EXPLAINNOFV EXPLAINNOLOOP EXPLAINCAT EXPLAINATTBIV
EXPLAINVL EXPLAINBVL EXPLAINSINGLERINGS)
(VARS (EXPLAININDENT 0)
(EXPLAINLEVEL 0))
(PROP EXPLAINATION MOLECULES GENMOL RINGS STRUCTURESWITHATOMS
RINGSKELETONS ATTACHFVS NOFVRINGS NOLOOPEDRINGS CATALOG
ATTACHBIVALENTS ATTACHBIVS&LOOPS SINGLERINGS)
(USERMACROS EXPLAINALL EXPLAIN ⊗ @ SLEVEL SWHICH)))
(* Everything needed to do an "EXPLAIN" command)
(DEFINEQ
(EXPLAIN
[LAMBDA (FORM PREFIX NOMOREINDENT)
(* This function is the driver for the EXPLAIN
package. It prints the explaination for any given
FORM. Requires the setting of "EXPLAINLEVEL" and
"EXPLAININDENT"; EXPLAINLEVEL is the depth to which
explainations should go (and a negative value means
never to DRAW structures or expand out sublists))
(* The explaination for STRUCFORM's is driven off
the property lists of functions;
give the function a property "EXPLAINATION" of a
function, with the same arguments;
however that the "EXPLAINATION" function prints an
explaination of what the real function generates
with those given arguments.
Rules are that the function should not carriage
return afterwards; and may use a variety of the
functions already available
(i.e. PRINCL is a good way of explaining a
composition list of atoms / structures))
(* PREFIX is a thing to be printed on the same line
with the beginning of the explaination;
NOMOREINDENT means not to bump the EXPLAININDENT)
(PROG [(EXPLAININDENT (COND
[EXPLAININDENT (TAB EXPLAININDENT)
(COND
(NOMOREINDENT
EXPLAININDENT)
(T (IPLUS 5 EXPLAININDENT]
(T 5)))
(EXPLAINLEVEL (COND
((NULL EXPLAINLEVEL -30))
((EQ EXPLAINLEVEL 0)
0)
((MINUSP EXPLAINLEVEL)
(ADD1 EXPLAINLEVEL))
(T (SUB1 EXPLAINLEVEL]
(COND
(PREFIX (MAPRINT PREFIX T NIL " " "")))
(PRIN1
(COND
((STRUCLIST? FORM)
(COND
((ILESSP EXPLAINLEVEL 1)
(PROG (FORMS LISTS OTHER STRUCS RADS FLG)
[FOR X IN (fetch LISTITEMS of FORM)
AS I
FROM 1
DO (COND
((STRUCLIST? X)
(SETQ LISTS (CONS I LISTS)))
((STRUCFORM? X)
(SETQ FORMS (CONS I FORMS)))
((STRUCTURE? X)
(SETQ STRUCS (CONS I STRUCS)))
((RADICAL? X)
(SETQ RADS (CONS I RADS)))
(T (SETQ OTHER (CONS I OTHER]
(PRINNUMLISTS
FORMS "forms:" LISTS "sublists:" STRUCS
"structures:" RADS "radicals:" OTHER
"garbage:"))
"")
(T (PRIN1 "List with:" T)
(FOR X IN (fetch LISTITEMS of FORM) AS I
FROM 1
DO (EXPLAIN X (LIST "#" I)))
"
")))
((STRUCFORM? FORM)
(COND
((ZEROP EXPLAINLEVEL)
(PRIN1 (CADR FORM)
T)
" expression")
((NOT (GETP (CADR FORM)
(QUOTE EXPLAINATION)))
(RESETFORM (PRINTLEVEL 2)
(PRIN1 (CDR FORM)
T))
"")
(T (APPLY (GETP (CADR FORM)
(QUOTE EXPLAINATION))
(CDDR FORM))
"")))
((OR (STRUCTURE? FORM)
(RADICAL? FORM))
(COND
((EQ (fetch LASTNODE# of FORM)
2)
[PRINMB (ATOMTYPE (CAR (fetch CTABLE of FORM)))
(FOR X
IN (fetch NBRS of
(CAR (fetch CTABLE of FORM)))
WHEN (NOT (EQ X (QUOTE FV)))
SUM 1)
(ATOMTYPE (CADR (fetch CTABLE of FORM]
"")
((ILESSP EXPLAINLEVEL 1)
(COND
((STRUCTURE? FORM)
"structure")
(T "radical")))
(T (PRIN1 "The structure:
" T)
(DRAW FORM)
"
")))
(T "garbage"))
T])
(PRINCL
[LAMBDA (CL)
(SETQ CL (SORT (APPEND CL)
T))
(PROG (FLG TEM BFLG)
(FOR X IN CL DO [SETQ TEM
(COND
((ATOM (CAR X))
(CAR X))
((AND (ATOM (CAAR X))
(GETP (CAAR X)
(QUOTE VALENCE)))
(CAAR X))
(T (AND FLG (NEQ FLG (QUOTE FOO))
(PRIN1 " and" T))
(SETQQ FLG FOO)
(EXPLAIN (CAR X)
(LIST (CDR X)))
(GO BYPASS]
(EXPLAINUPDATEFLG)
(PRIN1L (CDR X)
" " TEM)
BYPASS
(AND (IGREATERP (CDR X)
1)
(PRIN1 (QUOTE "'s ")
T])
(BONDING
[LAMBDA (U)
(SELECTQ U
(1 "-")
(2 "=")
(3 ":::")
(CONCAT "-" U "-"])
(PRINU
[LAMBDA (U)
(PRIN1L U (SELECTQ U
(1 " unsaturation, ")
" unsaturations, "])
(PRINMB
[LAMBDA (AT BND AT2)
(PRIN1L (OR AT "@")
(BONDING BND)
(OR AT2 "@")
" "])
(PRINNUMLIS
[LAMBDA (X)
(SETQ X (REVERSE X))
(PROG (LST)
(PRIN1 (SETQ LST (CAR X))
T)
(FOR OLD X ON (CDR X) AS FLG IS NIL
DO (FOR OLD X ON X WHILE (EQ (CAR X)
(SETQ LST (ADD1 LST)))
DO (SETQ FLG (CAR X)))
(COND
(FLG (PRIN1L "-" FLG)))
(COND
(X (PRIN1L "," (SETQ LST (CAR X])
(PRINNUMLISTS
[LAMBDA N
(PROG (FLG)
(FOR I FROM 1 TO N BY 2
DO (COND
((ARG N I)
(EXPLAINUPDATEFLG)
(PRIN1 (ARG N (ADD1 I))
T)
(PRINNUMLIS (ARG N I])
(EXPLAINVALENTNODE
[LAMBDA (NUMBERNODES VALENCE)
(PRIN1L (COND
((EQ NUMBERNODES 1)
"one")
(T NUMBERNODES))
" "
(SELECTQ VALENCE
(1 "uni")
(2 "bi")
(3 "tri")
(4 "quadri")
VALENCE)
(SELECTQ NUMBERNODES
(1 "valent")
"valents"])
(PRIN1L
[LAMBDA N
(FOR I FROM 1 TO N DO (PRIN1 (ARG N I)
T])
(EXPLAINUPDATEFLG
[LAMBDA NIL
(PRIN1 (COND
(FLG ", ")
(T " "))
T)
(SETQ FLG T])
(WHERE
[LAMBDA NIL
(PROG ((EXPRESSION (##))
(LEVEL (STRUCFORMLEVEL L))
TAIL)
(PRIN1L "Level " LEVEL)
[NLSETQ (PROG ((L L))
LP (SETQ WHICH (LENGTH (## UP)))
[SETQ L (EDITL0 L (QUOTE (!0]
(OR (STRUCLIST? (CAR L))
(GO LP))
(SETQ WHICH (CONS (IPLUS -1
(LENGTH (CAR L))
(IMINUS WHICH))
(STRUCFORMLEVEL L)))
(PRIN1L (COND
((EQ (SUB1 LEVEL)
(CDR WHICH))
", #")
(T " within #"))
(CAR WHICH)
" at level "
(CDR WHICH]
(PRIN1 ", " T)
(PROG ((EXPLAININDENT))
(EXPLAIN EXPRESSION)
(TERPRI T])
(STRUCFORMLEVEL
[LAMBDA (L)
(FOR X IN (CDR L) WHEN (STRUCFORM? X) SUM 1])
)
(DEFINEQ
(EXPLAINATIONMOLECULES
[LAMBDA (CL U)
(PRIN1 (QUOTE "Molecules with ")
T)
(PRINU U)
(PRINCL CL])
(EXPLAINGENMOL
[LAMBDA (CL)
(PRIN1 (QUOTE "all trees made out of")
T)
(PRINCL CL])
(EXPLAINRINGS
[LAMBDA (U CL)
(COND
((EQ (CLCOUNT CL)
2)
(SETQ CL (CLEXPAND CL))
(PRINMB (CAR CL)
(ADD1 U)
(CADR CL)))
(T (PRIN1 "rings with " T)
(PRINU U)
(PRINCL CL])
(EXPLAINSTRUCWAT
[LAMBDA (CLL STRUC)
(PRINCL (APPLY (QUOTE APPEND)
CLL))
(PRIN1 (QUOTE " placed on ")
T)
(EXPLAIN STRUC])
(EXPLAINRINGSKEL
[LAMBDA (FV VL)
(PRIN1 "Ring skeletons with " T)
(PRIN1 FV T)
(PRIN1 " free valences," T)
(EXPLAINVL VL])
(EXPLAINATTACFVS
[LAMBDA (FVL STRUC)
(EXPLAIN STRUC NIL T)
(PRIN1 ", with " T)
(PROG (FLG)
(FOR FVR IN FVL AS VALNODE FROM 2 FOR FVI IN FVR
AS NUMFV
FROM 1
WHEN (NOT (ZEROP FVI))
DO (EXPLAINUPDATEFLG)
(EXPLAINVALENTNODE FVI VALNODE)
(PRIN1L " getting " NUMFV " free valences"])
(EXPLAINNOFV
[LAMBDA (FV)
(PRIN1 "rings with " T)
(EXPLAINVL FV])
(EXPLAINNOLOOP
[LAMBDA (VL)
(PRIN1 "non-looped " T)
(EXPLAINNOFV VL])
(EXPLAINCAT
[LAMBDA (TVL)
(PRIN1 "catalog entries with " T)
(EXPLAINVL (CONS (QUOTE 0)
TVL])
(EXPLAINATTBIV
[LAMBDA (BVP STRUC)
(EXPLAIN STRUC NIL T)
(PRIN1 ", with" T)
(PROG (FLG)
(FOR PR IN BVP WHEN (NOT (ZEROP (CAR PR)))
DO (EXPLAINUPDATEFLG)
(PRIN1L (CAR PR)
" bivalents placed on "
(CDR PR)
(COND
((EQ (CDR PR)
1)
" edge")
(T " edges"])
(EXPLAINVL
[LAMBDA (VL)
(PROG (FLG)
(FOR X IN VL AS I FROM 2 WHEN (NOT (ZEROP X))
DO (EXPLAINUPDATEFLG)
(EXPLAINVALENTNODE X I])
(EXPLAINBVL
[LAMBDA (BVP LPP STRUC)
(EXPLAINATTBIV BVP STRUC)
(PROG (FLG)
(FOR VLPP IN LPP AS NV FROM 2 FOR PR IN VLPP
DO (EXPLAINUPDATEFLG)
(EXPLAINVALENTNODE (CDR PR)
NV)
(PRIN1 " getting " T)
(COND
((NULL (CDR (CAR PR)))
(PRIN1 (SELECTQ (CDAAR PR)
(1 " a loop with ")
(PROGN (PRIN1 (CDAAR PR)
T)
" loops with "))
T)
(EXPLAINVALENTNODE (CAAAR PR)
2))
(T (PRIN1L (CLCOUNT (CAR PR))
" loops (")
(PROG (FLG)
(FOR PR1 IN (CAR PR)
DO (EXPLAINUPDATEFLG)
(PRIN1L (CAR PR1)
" bivalents on "
(CDR PR1)
" of them ")))
(PRIN1 ")" T])
(EXPLAINSINGLERINGS
[LAMBDA (NUMBIVS)
(PRIN1 "ring of " T)
(EXPLAINVALENTNODE NUMBIVS 2])
)
(RPAQ EXPLAININDENT 0)
(RPAQ EXPLAINLEVEL 0)
(DEFLIST(QUOTE(
(MOLECULES EXPLAINATIONMOLECULES)
(GENMOL EXPLAINGENMOL)
(RINGS EXPLAINRINGS)
(STRUCTURESWITHATOMS EXPLAINSTRUCWAT)
(RINGSKELETONS EXPLAINRINGSKEL)
(ATTACHFVS EXPLAINATTACFVS)
(NOFVRINGS EXPLAINNOFV)
(NOLOOPEDRINGS EXPLAINNOLOOP)
(CATALOG EXPLAINCAT)
(ATTACHBIVALENTS EXPLAINATTBIV)
(ATTACHBIVS&LOOPS EXPLAINBVL)
(SINGLERINGS EXPLAINSINGLERINGS)
))(QUOTE EXPLAINATION))
(ADDTOVAR USERMACROS (@ NIL (@ 1))
[@ (EXPLEVEL)
(ORR (UP 1 SWHICH SLEVEL (E (PROG ((EXPLAINLEVEL
EXPLEVEL))
(WHERE))
T))
((E (QUOTE ?]
(EXPLAIN NIL (EXPLAIN -100))
[EXPLAIN (EXPLEVEL)
(ORR ((E (PROG ((EXPLAINLEVEL EXPLEVEL))
(EXPLAIN (##))
(TERPRI T))
T))
((E (QUOTE ?]
(EXPLAINALL NIL (EXPLAIN 100))
(SLEVEL NIL MARK (E (SETQ LEVEL 0)
T)
(LPQ UPFORM (E (SETQ LEVEL (ADD1 LEVEL))
T))
←←)
(SWHICH NIL MARK (ORR ((E (SETQ WHICH)
T)
[LC UP (E (SETQ WHICH
(LENGTH (##)))
T)
0
(IF (STRUCLIST? (##))
(NIL)
((E (ERROR!)
T]
(E (SETQ WHICH
(IPLUS -1 (LENGTH (##))
(IMINUS WHICH)))
T)
(E (PROG (LEVEL)
(## SLEVEL)
(SETQ WHICH (CONS WHICH
LEVEL)))
T))
(NIL))
←←))
(ADDTOVAR EDITCOMSA SWHICH SLEVEL EXPLAINALL EXPLAIN @)
(ADDTOVAR EDITCOMSL EXPLAIN @)
STOP